Unit BTestProjectRunnerUnit;

{$mode objfpc}{$H+}

Interface

Uses
  Classes, SysUtils, syncobjs, process, LiteLCLProc;

Const
  rsStart = 1;
  rsUnused = 1;
  rsWorking = 2;
  rsFinished = 3;
  rsFailed = 4;
  rsEnd = 4;

Type

{ BTestRunnerClass }

  BTestRunnerClass = Class
    Type

    { BRunnerThreadClass }

 BRunnerThreadClass = Class(TThread)
    Private
      bOutput: String;
      Function GetStatus: Integer;
      Protected
        bThreadSection: TCriticalSection;
        bProcess: TProcess;
        bStatus: Integer;
        bProject: String;
        bTarget: String;
        Procedure Execute; override;
      Public
        Property Status: Integer Read GetStatus;
        Property Output: String Read bOutput;

        Constructor Build(Const aSection: TCriticalSection;
          Const aProject: String; Const aTarget: String = ' -a ');
        Destructor Burn;
    End;

  Private
    bOutput: String;
    bThread: BRunnerThreadClass;
    bSection: TCriticalSection;
    bStatus: Integer;
    bReady: Boolean;
    Function GetStatus: Integer;
    Function ExtractCasesFromFile(Const aFilename: String): String;
  Public
    Property Status: Integer Read GetStatus;
    Property Output: String Read bOutput;
    Procedure Run(Const aProject: String);
    Procedure Run(Const aProject: String; Const aTestCaseFile: String;
      Const aIsTestName: Boolean = FALSE);

    Function Prepare: Boolean;

    Constructor Build;
    Destructor Burn;
End;

Implementation

{ BTestRunnerClass.BRunnerThreadClass }

Function BTestRunnerClass.BRunnerThreadClass.GetStatus: Integer;
Begin
  bThreadSection.Enter;
  Result := bStatus;
  bThreadSection.Leave;
end;

Procedure BTestRunnerClass.BRunnerThreadClass.Execute;
Var
  aBuffer: TStringList;
  aSize: Integer = 0;
  aBufferSize: Integer = 0;
  aStream: TMemoryStream;
  aCompileTime: TDateTime;
Begin
  bThreadSection.Enter;
  bStatus := rsWorking;
  bThreadSection.Leave;

  aCompileTime := Now;
  aBuffer := TStringList.Create;
  With TProcess.Create(nil) Do
    Begin
      Options := Options + [poUsePipes];
      CommandLine := 'lazbuild ' + bProject;
      Execute;
      aStream := TMemoryStream.Create;
      While (Running) Do
        Begin
          aStream.SetSize(aSize  + 2048);
          aBufferSize := Output.Read((aStream.Memory + aSize)^, 2048);
          If aBufferSize > 0 Then aSize += aBufferSize
          Else Sleep(100);
        End;
      Repeat
        aStream.SetSize(aSize + 2048);
        aBufferSize := Output.Read((aStream.Memory + aSize)^, 2048);
        If aBufferSize > 0 Then
          aSize += aBufferSize;
      Until Not(aBufferSize > 0);
      aStream.SetSize(aSize);

      aBuffer.LoadFromStream(aStream);
      aStream.Free;
      Free;
    End;
  aCompileTime := Now - aCompileTime;

  If Pos('ERROR: ', aBuffer.Text) > 0 Then
    Begin
      bThreadSection.Enter;
      bStatus := rsFailed;
      bThreadSection.Leave;
    End
  Else
    With TProcess.Create(nil) Do
      Begin
        Options := Options + [poUsePipes];
        CommandLine := ExtractFileNameWithoutExt(bProject) + bTarget +
          ' --format=plain';
        WriteLn('CommandLine: ', CommandLine);
        Execute;
        WaitOnExit;
        aBuffer.LoadFromStream(Output);
        Free;
      End;

  bThreadSection.Enter;
  bStatus := rsFinished;
  bThreadSection.Leave;

  bOutput := 'Compile time: ' + FormatDateTime('ss.zz', aCompileTime) + #13;
  bOutput += aBuffer.Text;
  aBuffer.Free;

  If (Pos('List of failures:', bOutput) > 0) Or
    (Pos('List of errors:', bOutput) > 0) Then
    bStatus := rsFailed
  Else
    bStatus := rsFinished;
End;

Constructor BTestRunnerClass.BRunnerThreadClass.Build(
  Const aSection: TCriticalSection; Const aProject: String;
  Const aTarget: String);
Begin
  bThreadSection := aSection;
  bProject := aProject;
  bTarget := aTarget;
  Inherited Create(FALSE);
End;

Destructor BTestRunnerClass.BRunnerThreadClass.Burn;
Begin
  Inherited Destroy;
End;

{ BTestRunnerClass }

Function BTestRunnerClass.GetStatus: Integer;
Var
  i: Integer;
Begin
  If bStatus = rsWorking Then
    If Assigned(bThread) Then
      Begin
        Sleep(2);
        bStatus := bThread.Status;
        If bStatus In [rsFinished, rsFailed] Then
          Begin
            bOutput := bThread.Output;
            bThread.Terminate;
            bThread.WaitFor;
            bThread.Burn;
            bThread := nil;
          End;
      End;
  Result := bStatus;
end;

Function BTestRunnerClass.ExtractCasesFromFile(Const aFilename: String): String;
Var
  i: Integer;
Begin
  Result := '';
  If Not(FileExists(aFilename)) Then Exit(' -a ');
  With TStringList.Create Do
    Begin
      LoadFromFile(aFilename);
      For i := 0 To Count - 1 Do
        If (Pos('Class(TTestCase)', Strings[i]) > 0) And
          (Pos('=', Strings[i]) > 0) Then
          Begin
            If Not(Result = '') Then Result += ',';
            Result += Trim(Copy(Strings[i], 1, Pos('=', Strings[i]) - 1));
          End;
      Free;
    End;
  If Result = '' Then Result := ' -a '
  Else Result := ' --suite=' + Result + ' ';
End;

Procedure BTestRunnerClass.Run(Const aProject: String);
Begin
  If Not(bReady) Or Not(bThread = nil) Then Exit;
  bStatus := rsWorking;
  bThread := BRunnerThreadClass.Build(bSection, aProject);
End;

Procedure BTestRunnerClass.Run(Const aProject: String;
  Const aTestCaseFile: String; Const aIsTestName: Boolean);
Var
  aTestCase: String;
Begin
  If Not(bReady) Or Not(bThread = nil) Then Exit;
  bStatus := rsWorking;
  If aIsTestName Then
    aTestCase := ' --suite=' + aTestCaseFile
  Else
    aTestCase := ExtractCasesFromFile(aTestCaseFile);
  WriteLn('aTestCase: ', aTestCase);
  bThread := BRunnerThreadClass.Build(bSection, aProject, aTestCase);
End;

Function BTestRunnerClass.Prepare: Boolean;
Begin
  Result := FALSE;
  If Not(bThread = nil) Then Exit;

  bStatus := rsUnused;
  bOutput := '';
  bReady := TRUE;
  Result := TRUE;
End;

Constructor BTestRunnerClass.Build;
Begin
  bStatus := rsUnused;
  bSection := TCriticalSection.Create;
  bThread := nil;
End;

Destructor BTestRunnerClass.Burn;
Begin
  bSection.Free;
End;

End.

